Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Peter Lewis/PNL Libraries/MyDatabase.p

Text File | 1994-09-11 | 16.0 KB | 577 lines | [TEXT/PJMM]

unit MyDatabase;

interface

{$IFC undefined THINK_Pascal}
    uses
        Files;
{$ENDC}

    const
        DB_Normal = 0;
        DB_CaseSensitive = $00000001;
        DB_Null = 0;

    const
        fileFormatErr = -10;
        duplicateKeyErr = -11;
        keyNotFoundErr = -12;

    function DatabaseCreate (var fs: FSSpec; hashsize: integer; flags: longInt): OSErr;
{ You should create the file before calling this using FSpCreate.  And existing data will be destroyed. }
{ hashsize is the number of hash table entries (initial file size will be around 4*hashsize }
{ hashsize should be prime }
    function DatabaseOpen (var fs: FSSpec; var refnum: longInt): OSErr;
    function DatabaseFlush (refnum: longInt): OSErr;
    function DatabaseClose (refnum: longInt): OSErr;
    function DatabaseAdd (refnum: longInt; key: str255; data: handle; overwriteok: boolean): OSErr;
    function DatabaseSetInfo (refnum: longInt; key: str255; var id: longInt; size: longInt; overwriteok: boolean): OSErr;
    function DatabaseSetChunk (refnum: longInt; id: longInt; pos, len: longInt; data: handle): OSErr;
    function DatabaseGet (refnum: longInt; key: Str255; data: handle): OSErr; { data may be nil }
    function DatabaseGetInfo (refnum: longInt; key: Str255; var id: longInt; var size: longInt): OSErr;
    function DatabaseGetChunk (refnum: longInt; id: longInt; pos, len: longInt; data: handle): OSErr;
    function DatabaseDelete (refnum: longInt; key: Str255; data: handle): OSErr; { data may be nil }
    function DatabaseIndex (refnum: longInt; var pos: longInt; var key: Str255; data: handle): OSErr;
{ pass in zero the first time, then whatever you got last time to get next.   data may be nil }
    function DatabasePack (refnum: longInt): OSErr;
{ uses about hashsize*8+8k memory in the heap }

implementation

    uses
{$IFC undefined THINK_Pascal}
        Memory, Packages,
{$ENDC}
        MyFileSystemUtils, MyMemory;

    const
        File_Magic = 'PLDB';
        Current_Version = 1;
        Max_Hash = 8001;
        free_next = -1;

{ File format: }
{ magic:longInt }
{ version: longint }
{ flags:longInt }
{ hashsize: integer}
{ hashtable: array[1..hashsize] of entryptr (offset into file) }
{ entry is: }
{ next:entryptr }
{ keylen:integer }
{ datalen:integer }
{ key:bytes }
{ data:bytes }
{ free entries have next=-1.  next links always point further into the file, never backwards }

    type
        ShortFileHeader = record
                magic: OSType;
                version: longInt;
                flags: longInt;
                hashsize: integer;
                rn: integer; { not valid in file obviously }
            end;
        HashTableArray = array[0..Max_Hash] of longInt;
        LongFileHeader = record
                magic: OSType;
                version: longInt;
                flags: longInt;
                hashsize: integer;
                rn: integer; { not valid in file obviously }
                hashtable: HashTableArray;
            end;
        FileHeaderPtr = ^LongFileHeader;
        FileHeaderHandle = ^FileHeaderPtr;
        HashTablePtr = ^HashTableArray;
        EntryRecord = record
                next: longInt;
                keylen: integer;
                datalen: integer;
            end;

    const
        File_Header_Size = SizeOf(ShortFileHeader);
        Entry_Size = SizeOf(EntryRecord);

    function DatabaseCreate (var fs: FSSpec; hashsize: integer; flags: longInt): OSErr;
        var
            err, oerr: OSErr;
            fhp: FileHeaderPtr;
            count: longInt;
            rn: integer;
            i: integer;
    begin
        if hashsize > Max_Hash then
            hashsize := Max_Hash;
        count := File_Header_Size + 4 * hashsize;
        err := FSpOpenDF(fs, fsRdWrPerm, rn);
        if err = noErr then begin
            err := SetEOF(rn, count);
            if err = noErr then
                err := MNewPtr(fhp, count);
            if err = noErr then begin
                fhp^.magic := File_Magic;
                fhp^.version := Current_Version;
                fhp^.flags := flags;
                fhp^.hashsize := hashsize;
                for i := 0 to hashsize - 1 do begin
                    fhp^.hashtable[i] := 0;
                end;
                err := FSWrite(rn, count, ptr(fhp));
                MDisposePtr(fhp);
            end;
            oerr := FSClose(rn);
            if err = noErr then
                err := oerr;
        end;
        DatabaseCreate := err;
    end;

    function DatabaseOpen (var fs: FSSpec; var refnum: longInt): OSErr;
        var
            err, junk: OSErr;
            fh: ShortFileHeader;
            rn: integer;
            count: longInt;
            fhp: FileHeaderPtr;
    begin
        err := FSpOpenDF(fs, fsRdWrPerm, rn);
        if err = noErr then begin
            count := File_Header_Size;
            err := FSRead(rn, count, @fh);
            if err = noErr then begin
                if (fh.magic <> File_magic) or (fh.version <> Current_Version) or (fh.hashsize < 1) or (fh.hashsize > Max_Hash) then begin
                    err := fileFormatErr;
                end;
            end;
            if err = noErr then begin
                count := 4 * fh.hashsize;
                err := MNewPtr(fhp, File_header_Size + count);
            end;
            if err = noErr then begin
                BlockMove(@fh, ptr(fhp), File_Header_Size);
                fhp^.rn := rn;
                err := FSRead(rn, count, ptr(ord(fhp) + File_Header_Size));
                if err <> noErr then begin
                    MDisposePtr(fhp);
                end;
            end;
            if err <> noErr then begin
                junk := FSClose(rn);
            end;
        end;
        refnum := longInt(fhp);
        if err <> noErr then begin
            refnum := DB_Null;
        end;
        DatabaseOpen := err;
    end;

    function DatabaseFlush (refnum: longInt): OSErr;
        var
            err, oerr: OSErr;
            fhp: FileHeaderptr;
            pb: ParamBlockRec;
    begin
        fhp := FileHeaderPtr(refnum);
        err := MyFSWriteAt(fhp^.rn, fsFromStart, 0, GetPtrSize(ptr(fhp)), ptr(fhp));
        if err = noErr then begin
            pb.ioRefNum := fhp^.rn;
            err := PBFlushFileSync(@pb);
        end;
        DatabaseFlush := err;
    end;

    function DatabaseClose (refnum: longInt): OSErr;
        var
            err, oerr: OSErr;
            fhp: FileHeaderptr;
    begin
        fhp := FileHeaderPtr(refnum);
        err := MyFSWriteAt(fhp^.rn, fsFromStart, 0, GetPtrSize(ptr(fhp)), ptr(fhp));
        oerr := FSClose(fhp^.rn);
        if err = noErr then
            err := oerr;
        MDisposePtr(fhp);
        DatabaseClose := err;
    end;

    function Hash (var key: str255; hashsize: integer): integer;
        var
            h, i: integer;
    begin
        h := 0;
        for i := 1 to length(key) do begin
            h := ((32 * longInt(h)) + ord(key[i])) mod hashsize;
        end;
        Hash := h;
    end;

    function ReadEntry (fhp: FileHeaderPtr; pos: longInt; var entry: EntryRecord; var key: Str255): OSErr;
        var
            err: OSErr;
    begin
        err := MyFSReadAt(fhp^.rn, pos, Entry_Size, @entry);
        if err = noErr then begin
{$PUSH}
{$R-}
            key[0] := chr(entry.keylen);
{$POP}
            if entry.keylen > 0 then begin
                err := MyFSReadAt(fhp^.rn, pos + Entry_Size, entry.keylen, @key[1]);
            end;
        end;
        ReadEntry := err;
    end;

    function Find (fhp: FileHeaderPtr; var key: Str255; var h: integer; var preoffset, offset: longInt; var entry: EntryRecord): OSErr;
{ err = noErr ==> no error.  offset<>0 ==> found. preoffset is the fileoffset that points to offset (even if not found) }
        var
            err: OSErr;
            thiskey: str255;
    begin
        h := Hash(key, fhp^.hashsize);
        preoffset := File_Header_Size + 4 * h;
        offset := fhp^.hashtable[h];
        err := noErr;
        while (offset <> 0) & (err = noErr) do begin
            err := ReadEntry(fhp, offset, entry, thiskey);
            if err = noErr then begin
                if BAND(fhp^.flags, DB_CaseSensitive) <> 0 then begin
                    if thiskey = key then begin
                        leave;
                    end;
                end
                else begin
                    if IUEqualString(thiskey, key) = 0 then begin
                        leave;
                    end;
                end;
                preoffset := offset;
                offset := entry.next;
            end;
        end;
        Find := err;
    end;

    function WriteLink (fhp: FileHeaderPtr; pos: longInt; link: longInt): OSErr;
        var
            h: integer;
            err: OSErr;
    begin
        if pos >= File_Header_Size + 4 * fhp^.hashsize then begin
            err := MyFSWriteAt(fhp^.rn, fsFromStart, pos, 4, @link);
        end
        else begin
            err := noErr;
            h := (pos - File_Header_size) div 4;
            fhp^.hashtable[h] := link;
        end;
        WriteLink := err;
    end;

    function WriteFreeLink (fhp: FileHeaderPtr; pos: longInt): OSErr;
        var
            link: longInt;
    begin
        link := free_next;
        WriteFreeLink := MyFSWriteAt(fhp^.rn, fsFromStart, pos, 4, @link);
    end;

    function FindSpace (fhp: FileHeaderptr; key: str255; size: longInt; overwriteok: boolean; var offset: longInt): OSErr;
        var
            err, oerr: OSErr;
            h: integer;
            preoffset, v: longInt;
            entry: EntryRecord;
            filelen: longInt;
            oldsize: longInt;
    begin
        err := Find(fhp, key, h, preoffset, offset, entry);
        if (err = noErr) & (offset <> 0) & not overwriteok then
            err := duplicateKeyErr;
        if (err = noErr) & (offset <> 0) then begin
            if entry.datalen = size then begin
{ all set }
            end
            else if entry.datalen > size + Entry_Size then begin
                oldsize := entry.datalen;
                entry.datalen := size;
                err := MyFSWriteAt(fhp^.rn, fsFromStart, offset, Entry_Size, @entry);
                if err = noErr then begin
                    entry.next := free_next;
                    entry.keylen := 0;
                    entry.datalen := oldsize - size - Entry_Size;
                    err := MyFSWriteAt(fhp^.rn, fsFromStart, offset + Entry_Size + length(key) + size, Entry_Size, @entry);
                end;
            end
            else begin
                err := WriteLink(fhp, preoffset, entry.next);
                v := free_next;
                if err = noErr then
                    err := WriteFreeLink(fhp, offset);
                offset := entry.next;
                while (offset <> 0) & (err = noErr) do begin
                    err := MyFSReadAt(fhp^.rn, offset, 4, @entry);
                    if err = noErr then begin
                        preoffset := offset;
                        offset := entry.next;
                    end;
                end;
            end;
        end;
        if (err = noErr) & (offset = 0) then begin { add at end of file after entry at preoffset }
            err := GetEOF(fhp^.rn, filelen);
            if err = noErr then begin
                err := SetEOF(fhp^.rn, filelen + Entry_Size + length(key) + size);
            end;
            entry.next := 0;
            entry.keylen := length(key);
            entry.datalen := size;
            if err = noErr then
                err := MyFSWriteAt(fhp^.rn, fsFromStart, filelen, Entry_Size, @entry);
            if err = noErr then
                err := MyFSWrite(fhp^.rn, length(key), @key[1]);
            if err = noErr then begin
                err := WriteLink(fhp, preoffset, filelen);
            end;
            offset := filelen;
        end;
        offset := offset + Entry_Size + length(key);
        FindSpace := err;
    end;

    function DatabaseAdd (refnum: longInt; key: str255; data: handle; overwriteok: boolean): OSErr;
        var
            err: OSErr;
            fhp: FileHeaderptr;
            offset: longInt;
            handlesize: longInt;
            state: SignedByte;
    begin
        fhp := FileHeaderPtr(refnum);
        handlesize := GetHandleSize(data);
        err := FindSpace(fhp, key, handlesize, overwriteok, offset);
        if err = noErr then begin
            HLockState(data, state);
            err := MyFSWriteAt(fhp^.rn, fsFromStart, offset, handlesize, data^);
            HSetState(data, state);
        end;
        DatabaseAdd := err;
    end;

    function DatabaseSetInfo (refnum: longInt; key: str255; var id: longInt; size: longInt; overwriteok: boolean): OSErr;
        var
            err: OSErr;
            fhp: FileHeaderptr;
            state: SignedByte;
    begin
        fhp := FileHeaderPtr(refnum);
        err := FindSpace(fhp, key, size, overwriteok, id);
        DatabaseSetInfo := err;
    end;

    function DatabaseSetChunk (refnum: longInt; id: longInt; pos, len: longInt; data: handle): OSErr;
        var
            err: OSErr;
            fhp: FileHeaderptr;
            state: SignedByte;
    begin
        fhp := FileHeaderPtr(refnum);
        HLockState(data, state);
        err := MyFSWriteAt(fhp^.rn, fsFromStart, id + pos, GetHandleSize(data), data^);
        HSetState(data, state);
        DatabaseSetChunk := err;
    end;

    function Get (fhp: FileHeaderPtr; var key: Str255; var h: integer; var preoffset, offset: longInt; var entry: EntryRecord; data: handle): OSErr;
        var
            err: OSErr;
            state: SignedByte;
    begin
        err := Find(fhp, key, h, preoffset, offset, entry);
        if (err = noErr) & (offset = 0) then
            err := keyNotFoundErr;
        if err = noErr then begin
            if data <> nil then begin
                HUnlockState(data, state);
                SetHandleSize(data, entry.datalen);
                err := MemError;
                if err = noErr then begin
                    HLock(data);
                    err := MyFSReadAt(fhp^.rn, offset + Entry_Size + entry.keylen, entry.datalen, data^);
                end;
                HSetState(data, state);
            end;
        end;
        Get := err;
    end;

    function DatabaseGet (refnum: longInt; key: Str255; data: handle): OSErr;
        var
            h: integer;
            preoffset, offset: longInt;
            entry: EntryRecord;
    begin
        DatabaseGet := Get(FileHeaderPtr(refnum), key, h, preoffset, offset, entry, data);
    end;

    function DatabaseGetInfo (refnum: longInt; key: Str255; var id: longInt; var size: longInt): OSErr;
        var
            h: integer;
            preoffset, offset: longInt;
            entry: EntryRecord;
    begin
        DatabaseGetInfo := Get(FileHeaderPtr(refnum), key, h, preoffset, offset, entry, nil);
        id := offset + Entry_Size + entry.keylen;
        size := entry.datalen;
    end;

    function DatabaseGetChunk (refnum: longInt; id: longInt; pos, len: longInt; data: handle): OSErr;
        var
            err: OSErr;
            state: SignedByte;
    begin
        HUnlockState(data, state);
        SetHandleSize(data, len);
        err := MemError;
        if err = noErr then begin
            HLock(data);
            err := MyFSReadAt(FileHeaderPtr(refnum)^.rn, id + pos, len, data^);
        end;
        HSetState(data, state);
        DatabaseGetChunk := err; { Thanks Marcel/Metrowerks! }
    end;

    function DatabaseDelete (refnum: longInt; key: Str255; data: handle): OSErr; { data may be nil }
        var
            err: OSErr;
            fhp: FileHeaderptr;
            h: integer;
            preoffset, offset: longInt;
            entry: EntryRecord;
    begin
        fhp := FileHeaderPtr(refnum);
        err := Get(fhp, key, h, preoffset, offset, entry, data);
        if err = noErr then begin
            err := WriteLink(fhp, preoffset, entry.next);
            if err = noErr then
                err := WriteFreeLink(fhp, offset);
        end;
        DatabaseDelete := err;
    end;

    function DatabaseIndex (refnum: longInt; var pos: longInt; var key: Str255; data: handle): OSErr;
        var
            err: OSErr;
            fhp: FileHeaderptr;
            start, filelen: longInt;
            entry: EntryRecord;
            count: longInt;
    begin
        fhp := FileHeaderPtr(refnum);
        start := File_Header_Size + 4 * fhp^.hashsize;
        if pos = 0 then
            pos := start;
        err := GetEOF(fhp^.rn, filelen);
        entry.next := free_next;
        while (err = noErr) & (entry.next = free_next) & (start <= pos) & (pos < filelen) do begin
            err := ReadEntry(fhp, pos, entry, key);
            pos := pos + Entry_Size + entry.keylen + entry.datalen;
        end;
        if (err = noErr) & (entry.next = free_next) then
            err := keyNotFoundErr;
        if (err = noErr) & (data <> nil) then begin
            SetHandleSize(data, entry.datalen);
            err := MemError;
            if err = noErr then begin
                count := entry.datalen;
                err := FSRead(fhp^.rn, count, data^);
            end;
        end;
        DatabaseIndex := err;
    end;

    function DatabasePack (refnum: longInt): OSErr;
        const
            buffer_size = 8192;
        var
            err: OSErr;
            fhp: FileHeaderptr;
            preoffsets, offsets: HashTablePtr;
            start, filelen: longInt;
            srcpos, destpos: longInt;
            entry: EntryRecord;
            key: Str255;
            len, count: longInt;
            buffer: ptr;
            h: integer;
    begin
        fhp := FileHeaderPtr(refnum);
        err := MNewPtr(preoffsets, 4 * fhp^.hashsize);
        offsets := nil;
        if err = noErr then
            err := MNewPtr(offsets, 4 * fhp^.hashsize);
        buffer := nil;
        if err = noErr then
            err := MNewPtr(buffer, buffer_size);
        start := File_Header_Size + 4 * fhp^.hashsize;
        if err = noErr then
            err := GetEOF(fhp^.rn, filelen);
        if err = noErr then begin
            for h := 0 to fhp^.hashsize - 1 do begin
                preoffsets^[h] := File_header_Size + h * 4;
                offsets^[h] := fhp^.hashtable[h];
            end;
            srcpos := start;
            destpos := start;
            while (err = noErr) & (srcpos < filelen) do begin
                err := ReadEntry(fhp, srcpos, entry, key);
                if (err = noErr) then begin
                    len := Entry_Size + entry.keylen + entry.datalen;
                    if (entry.next = free_next) then begin { skip it }
                        srcpos := srcpos + len;
                    end
                    else begin
{ ok, now we need to move this entry from srcpos to destpos, updating the link pointing to it }
{ Find hash }
                        h := Hash(key, fhp^.hashsize);
                        if (err = noErr) & (offsets^[h] <> srcpos) then
                            err := fileFormatErr;
{ Update link }
                        if err = noErr then
                            err := WriteLink(fhp, preoffsets^[h], destpos);
                        preoffsets^[h] := destpos;
                        offsets^[h] := entry.next;
{ Copy entry }
                        if srcpos = destpos then begin
                            destpos := destpos + len;
                            srcpos := srcpos + len;
                        end
                        else begin
                            while (err = noErr) & (len > 0) do begin
                                count := len;
                                if count > buffer_size then
                                    count := buffer_size;
                                err := MyFSReadAt(fhp^.rn, srcpos, count, buffer);
                                if err = noErr then
                                    err := MyFSWriteAt(fhp^.rn, fsFromStart, destpos, count, buffer);
                                len := len - count;
                                srcpos := srcpos + count;
                                destpos := destpos + count;
                            end;
                        end;
                    end;
                end;
            end;
            if err = noErr then
                err := SetEOF(fhp^.rn, destpos);
        end;
        MDisposePtr(preoffsets);
        MDisposePtr(offsets);
        MDisposePtr(buffer);
        DatabasePack := err;
    end;

end.